home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Text files / Math < prev    next >
Encoding:
Text File  |  1991-07-19  |  2.6 KB  |  60 lines  |  [TEXT/EDIT]
  1. ( Math routines for Pocket Forth )
  2.  
  3. : 2ROOT ( d -- n ) ( square root ) ( Forth assembler syntax )
  4.     ,$ 48E7  ,$ 2800  ( .long SP -] 2800 movem>, )
  5.     ,$ 2016           ( PS ] D0 move, )
  6.     ,$ 383C  ,$ 000F  ( .word  15 # D4 move,  .long )
  7.     ,$ 7200  ,$ 7400  ( 0 D1 moveq, 0 D2 moveq, )
  8.     ,$ E380  ,$ E391  ( DO,  1 # D0 asl,  1 # D1 roxl, )
  9.     ,$ E380  ,$ E391  (   1 # D0 asl,  1 # D1 roxl, )
  10.     ,$ E382  ,$ 2602  (   1 # D2 asl,  D2 D3 move, )
  11.     ,$ E383  ,$ B283  (   1 # D3 asl,  D3 D1 cmp, )
  12.     ,$ 6306           (   ls IF, )
  13.     ,$ 5282  ,$ 5283  (     1 D2 addq,  1 D3 addq, )
  14.     ,$ 9283           (     D3 D1 sub,  THEN, )
  15.     ,$ 51CC  ,$ FFE6  ( D4 LOOP, )
  16.     ,$ 2C82           ( D2 PS ] move, )
  17.     ,$ 4CDF  ,$ 0014  ( 14 SP ]+ movem<, )
  18.     drop ;
  19. : ^2 ( n -- d ) dup u* ;  ( square )
  20. : RANDOM ( n -- n' ) ( random number from 0 to n )
  21.     0 >r ,$ A861  r> ( _Random )
  22.     swap 32768 */ abs ;  ( scale to size from stack )
  23.  
  24. variable TTABLE  0 ttable !  ( sines*10000 )
  25.     00175 , 00349 , 00524 , 00698 , 00872 , 01045 , 01219 , 01392 ,
  26.     01571 , 01736 , 01908 , 02079 , 02250 , 02419 , 02588 , 02756 ,
  27.     02924 , 03090 , 03256 , 03420 , 03584 , 03746 , 03907 , 04067 ,
  28.     04226 , 04384 , 04540 , 04695 , 04848 , 05000 , 05150 , 05299 ,
  29.     05446 , 05592 , 05736 , 05878 , 06018 , 06157 , 06293 , 06428 ,
  30.     06561 , 06691 , 06820 , 06947 , 07071 , 07193 , 07314 , 07431 ,
  31.     07547 , 07660 , 07771 , 07880 , 07986 , 08090 , 08192 , 08290 ,
  32.     08387 , 08480 , 08572 , 08660 , 08746 , 08829 , 08910 , 08988 ,
  33.     09063 , 09135 , 09205 , 09272 , 09336 , 09397 , 09455 , 09511 ,
  34.     09563 , 09613 , 09659 , 09703 , 09744 , 09781 , 09816 , 09848 ,
  35.     09877 , 09903 , 09925 , 09945 , 09962 , 09976 , 09986 , 09994 ,
  36.     09998 , 10000 ,
  37.  
  38. : ?NEGATE ( n f -- n or -n ) IF negate THEN ;
  39. : FIXANGLE ( angle -- angle' ) ( map angle to -180° to 180° range )
  40.     dup abs  BEGIN  dup 180 > WHILE  360 - REPEAT
  41.     swap 0< ?negate ;
  42.  
  43. : SIN ( angle -- sin*10000 ) ( -180°≤angle≤180° )
  44.     fixangle dup 0< >r  abs  dup 90 > IF  180 swap - THEN
  45.       2* ttable + @  r> ?negate ;
  46. : COS ( angle -- cos*10000 )
  47.     dup 0< IF 90 + sin  ELSE  90 - sin negate THEN ;
  48. : ARCSIN ( sine*10000 -- angle )
  49.     dup 0< >r  abs  ( save sign )
  50.       91 0 DO  ( check all angles )
  51.         dup r 2* ttable + @ > 0= IF  ( if sin>table value )
  52.         drop r  leave THEN  LOOP
  53.     r> ?negate ; ( restore sign )
  54.  
  55. ( interpolate for greater accuracy )
  56. : SINE ( angle thousanths -- sine*10000 )
  57.     >r  >r  r sin  r> 1+ sin  over -  r> 1000 */ + ;
  58. : COSINE ( angle thousanths -- cosine*10000 )
  59.     >r >r  r cos  r> 1+ cos  over -  r> 1000 */ + ;
  60.